home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Cartiers-Contribs / Modules / extended-apropos / tools.lisp < prev   
Encoding:
Text File  |  1992-09-08  |  3.0 KB  |  127 lines  |  [TEXT/CCL2]
  1. ;;; -*- package: CC -*-
  2. ;;;
  3. ;;;; Tools for the extended apropos
  4. ;;;
  5.  
  6.  
  7. (in-package "CC")
  8.  
  9.  
  10. ;;;
  11. ;;;; Selection pop up
  12. ;;;
  13.  
  14.  
  15. (defclass selection-pop-up (pop-up-menu)
  16.     ((list :initarg :list :initform nil)
  17.      (menu-item-action :initarg :menu-item-action :initform nil)))
  18.  
  19.  
  20. (defclass selection-menu-item (menu-item)
  21.     ((value :initarg :value)))
  22.  
  23.  
  24. (defmethod selected-item ((self selection-pop-up))
  25.   (slot-value (call-next-method)
  26.               'value))
  27.  
  28.  
  29. (defmethod initialize-instance :after ((self selection-pop-up) &key)
  30.   (with-slots (list menu-item-action) self
  31.     (apply (function add-menu-items) self
  32.            (iter (for (value text) in list)
  33.                  (collect
  34.                    (if (and (null value)
  35.                             (null text))
  36.                        (make-instance 'menu-item
  37.                          :menu-item-title "-")
  38.                      (make-instance 'selection-menu-item
  39.                        :value value
  40.                        :menu-item-title text
  41.                        :menu-item-action
  42.                        (function
  43.                          (lambda ()
  44.                            (when menu-item-action
  45.                              (funcall menu-item-action))
  46.                            (auto-search-action))))))))))
  47.  
  48.  
  49. ;;;
  50. ;;;; Contour mixin
  51. ;;;
  52.  
  53.  
  54. (defclass apropos-contour-view (view)
  55.     ())
  56.  
  57.  
  58. (defmethod install-view-in-window :after ((self apropos-contour-view) window)
  59.   (declare (ignore window))
  60.   (set-view-size self (apropos-contour-size (subviews self))))
  61.  
  62.  
  63. (defun apropos-contour-size (views)
  64.   (iter (for view in views)
  65.         (for pos    = (view-position view))
  66.         (for size   = (or (view-size view) (view-default-size view)))
  67.         (for left   = (point-h pos))
  68.         (for top    = (point-v pos))
  69.         (for right  = (+ left (point-h size)))
  70.         (for bottom = (+ top  (point-v size)))
  71.         (minimizing left   into min-left)
  72.         (minimizing top    into min-top)
  73.         (maximizing right  into max-right)
  74.         (maximizing bottom into max-bottom)
  75.         (finally (return (make-point (+ 5 min-left max-right)
  76.                                      (+ min-top  max-bottom))))))
  77.  
  78.  
  79. ;;;
  80. ;;;; A window that hides when closed
  81. ;;;
  82.  
  83.  
  84. (defclass apropos-hide-window (window)
  85.     ())
  86.  
  87.  
  88. (defvar *apropos-force-close* nil)
  89.  
  90.  
  91. (defmethod window-close :around ((window apropos-hide-window))
  92.   (if *apropos-force-close*
  93.       (call-next-method)
  94.     (window-hide window)))
  95.  
  96. (defmethod window-apropos-force-close ((window apropos-hide-window))
  97.   (let ((*apropos-force-close* t))
  98.     (window-close window)))
  99.  
  100.  
  101. ;;;
  102. ;;;; Various
  103. ;;;
  104.  
  105.  
  106. (defun compatible-modifiers ()
  107.   (list (shift-key-p)
  108.         (or (control-key-p)
  109.             (command-key-p))
  110.         (option-key-p)))
  111.  
  112.  
  113. (defun inverse (predicate)
  114.   (function
  115.     (lambda (x)
  116.       (not (funcall predicate x)))))
  117.  
  118.  
  119. (defmethod find-view ((view view) name)
  120.   (labels ((find-aux (subview)
  121.              (if (eql (view-nick-name subview) name)
  122.                  (return-from find-view subview)
  123.                (do-subviews (x subview)
  124.                  (find-aux x)))))
  125.     (find-aux view)
  126.     nil))
  127.